home *** CD-ROM | disk | FTP | other *** search
/ Super Shareware Collection / Super Shareware Collection.iso / os_2 / clisp.zip / MACROS1.LSP < prev    next >
Text File  |  1994-02-05  |  18KB  |  520 lines
  1. ;;;; Definitionen für Kontrollstrukturen etc.
  2. ;;;; 29. 4. 1988, 3. 9. 1988
  3.  
  4. (in-package "LISP")
  5. (export '(mapcap maplap))
  6. (in-package "SYSTEM")
  7.  
  8. (defmacro defvar (symbol &optional (initial-value nil svar) docstring)
  9.   (unless (symbolp symbol)
  10.     (error #+DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  11.            #+ENGLISH "~S: non-symbol ~S can't be a variable"
  12.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S"
  13.            'defvar symbol
  14.   ) )
  15.   (if (constantp symbol)
  16.     (error #+DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  17.            #+ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  18.            #+FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  19.            'defvar symbol
  20.   ) )
  21.   `(LET ()
  22.      (PROCLAIM '(SPECIAL ,symbol))
  23.      ,@(if svar
  24.          `((UNLESS (BOUNDP ',symbol) (SET ',symbol ,initial-value)))
  25.        )
  26.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  27.      ',symbol
  28.    )
  29. )
  30.  
  31. (defmacro defparameter (symbol initial-value &optional docstring)
  32.   (unless (symbolp symbol)
  33.     (error #+DEUTSCH "~S: Nur Symbole können Variablen sein, nicht ~S"
  34.            #+ENGLISH "~S: non-symbol ~S can't be a variable"
  35.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de variable et non ~S."
  36.            'defparameter symbol
  37.   ) )
  38.   (if (constantp symbol)
  39.     (error #+DEUTSCH "~S: Die Konstante ~S darf nicht zu einer Variablen umdefiniert werden."
  40.            #+ENGLISH "~S: the constant ~S must not be redefined to be a variable"
  41.            #+FRANCAIS "~S : La constante ~S ne peut pas être redéfinie en variable."
  42.            'defparameter symbol
  43.   ) )
  44.   `(LET ()
  45.      (PROCLAIM '(SPECIAL ,symbol))
  46.      (SET ',symbol ,initial-value)
  47.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  48.      ',symbol
  49.    )
  50. )
  51.  
  52. (defmacro defconstant (&whole form symbol initial-value &optional docstring)
  53.   (unless (symbolp symbol)
  54.     (error #+DEUTSCH "~S: Nur Symbole können als Konstanten definiert werden, nicht ~S"
  55.            #+ENGLISH "~S: non-symbol ~S can't be a defined constant"
  56.            #+FRANCAIS "~S : Seuls les symboles peuvent servir de constante et non ~S."
  57.            'defconstant symbol
  58.   ) )
  59.   `(LET ()
  60.      (EVAL-WHEN (COMPILE)
  61.        (COMPILER::C-PROCLAIM-CONSTANT ',symbol ',initial-value)
  62.      )
  63.      (IF (CONSTANTP ',symbol)
  64.        (WARN #+DEUTSCH "In ~S wird die Konstante ~S umdefiniert. Ihr alter Wert war ~S."
  65.              #+ENGLISH "~S redefines the constant ~S. Its old value was ~S."
  66.              #+FRANCAIS "~S redéfinit la constante ~S. Son ancienne valeur était ~S."
  67.              ',form ',symbol (SYMBOL-VALUE ',symbol)
  68.      ) )
  69.      (SYS::%PROCLAIM-CONSTANT ',symbol ,initial-value)
  70.      ,@(if docstring `((SYS::%SET-DOCUMENTATION ',symbol 'VARIABLE ',docstring)))
  71.      ',symbol
  72.    )
  73. )
  74.  
  75. (sys::%put 'and 'sys::macro
  76.   (sys::macro-expander and (&body args)
  77.     (cond ((null args) T)
  78.           ((null (cdr args)) (car args))
  79.           (t (let ((L (mapcar #'(lambda (x) `((NOT ,x) NIL) ) args)))
  80.                (rplaca (last L) `(T ,(car (last args))))
  81.                (cons 'COND L)
  82.   ) )     )  )
  83. )
  84.  
  85. (sys::%put 'or 'sys::macro
  86.   (sys::macro-expander or (&body args)
  87.     (cond ((null args) NIL)
  88.           ((null (cdr args)) (car args))
  89.           (t (let ((L (mapcar #'list args)))
  90.                (rplaca (last L) `(T ,(car (last args))))
  91.                (cons 'COND L)
  92.   ) )     )  )
  93. )
  94.  
  95. (sys::%put 'prog1 'sys::macro
  96.   (sys::macro-expander prog1 (form1 &rest moreforms)
  97.     (let ((g (gensym)))
  98.       `(LET ((,g ,form1)) ,@moreforms ,g)
  99.   ) )
  100. )
  101.  
  102. (sys::%put 'prog2 'sys::macro
  103.   (sys::macro-expander prog2 (form1 form2 &rest moreforms)
  104.     (let ((g (gensym)))
  105.       `(LET () (PROGN ,form1 (LET ((,g ,form2)) ,@moreforms ,g)))
  106.   ) )
  107. )
  108.  
  109. (sys::%put 'when 'sys::macro
  110.   (sys::macro-expander when (test &body forms)
  111.     `(IF ,test (PROGN ,@forms))
  112.   )
  113. )
  114.  
  115. (sys::%put 'unless 'sys::macro
  116.   (sys::macro-expander unless (test &body forms)
  117.     `(IF (NOT ,test) (PROGN ,@forms))
  118.   )
  119. )
  120.  
  121. (defmacro return (&optional return-value)
  122.   `(RETURN-FROM NIL ,return-value)
  123. )
  124.  
  125. (defmacro loop (&body body)
  126.   (let ((tag (gensym)))
  127.     `(BLOCK NIL (TAGBODY ,tag ,@body (GO ,tag)))
  128. ) )
  129.  
  130. (defun do/do*-expand (varclauselist exitclause body env do let psetq)
  131.   (when (atom exitclause)
  132.     (error #+DEUTSCH "Exitclause in ~S muß Liste sein."
  133.            #+ENGLISH "exit clause in ~S must be a list"
  134.            #+FRANCAIS "La clause de sortie dans ~S doit être une liste."
  135.            do
  136.   ) )
  137.   (let ((bindlist nil)
  138.         (reinitlist nil)
  139.         (testtag (gensym))
  140.         (exittag (gensym)))
  141.     (multiple-value-bind (body-rest declarations doc)
  142.                          (sys::parse-body body nil env)
  143.       (declare (ignore doc))
  144.       (if declarations
  145.         (setq declarations (list (cons 'DECLARE declarations)))
  146.       )
  147.       (loop
  148.         (when (atom varclauselist) (return))
  149.         (let ((varclause (first varclauselist)))
  150.           (setq varclauselist (rest varclauselist))
  151.           (cond ((atom varclause)
  152.                  (setq bindlist (cons varclause bindlist))
  153.                 )
  154.                 ((atom (cdr varclause))
  155.                  (setq bindlist (cons (first varclause) bindlist))
  156.                 )
  157.                 ((atom (cddr varclause))
  158.                  (setq bindlist (cons varclause bindlist))
  159.                 )
  160.                 (t (setq bindlist
  161.                      (cons (list (first varclause) (second varclause))
  162.                            bindlist
  163.                    ) )
  164.                    (setq reinitlist
  165.                      (list* (third varclause) (first varclause) reinitlist)
  166.       ) ) )     )  )
  167.       `(BLOCK NIL
  168.          (,let ,(nreverse bindlist)
  169.            ,@declarations
  170.            (TAGBODY
  171.              ,testtag
  172.              (IF ,(first exitclause) (GO ,exittag))
  173.              ,@body-rest
  174.              (,psetq ,@(nreverse reinitlist))
  175.              (GO ,testtag)
  176.              ,exittag
  177.              (RETURN-FROM NIL (PROGN ,@(rest exitclause)))
  178.        ) ) )
  179. ) ) )
  180.  
  181. (fmakunbound 'do)
  182. (defmacro do (varclauselist exitclause &body body &environment env)
  183.   (do/do*-expand varclauselist exitclause body env 'DO 'LET 'PSETQ)
  184. )
  185.  
  186. (defmacro do* (varclauselist exitclause &body body &environment env)
  187.   (do/do*-expand varclauselist exitclause body env 'DO* 'LET* 'SETQ)
  188. )
  189.  
  190. (defmacro dolist ((var listform &optional resultform) &body body &environment env)
  191.   (multiple-value-bind (body-rest declarations)
  192.                        (sys::parse-body body nil env)
  193.     (let ((g (gensym)))
  194.       `(DO* ((,g ,listform (CDR ,g))
  195.              (,var NIL))
  196.             ((ENDP ,g)
  197.              ,(if (constantp resultform)
  198.                ; Ist resultform konstant, so ist es /= var. Daher braucht var
  199.                ; während Auswertung von resultform nicht an NIL gebunden zu sein:
  200.                `,resultform
  201.                `(LET ((,var NIL))
  202.                   (DECLARE (IGNORABLE ,var) ,@declarations)
  203.                   ,resultform
  204.                 )
  205.               )
  206.             )
  207.          (DECLARE (LIST ,g) ,@declarations)
  208.          (SETQ ,var (CAR ,g))
  209.          ,@body-rest
  210.        )
  211. ) ) )
  212.  
  213. (fmakunbound 'dotimes)
  214. (defmacro dotimes ((var countform &optional resultform) &body body &environment env)
  215.   (multiple-value-bind (body-rest declarations)
  216.                        (sys::parse-body body nil env)
  217.     (if declarations
  218.       (setq declarations (list (cons 'DECLARE declarations)))
  219.     )
  220.     (if (constantp countform)
  221.       `(DO ((,var 0 (1+ ,var)))
  222.            ((>= ,var ,countform) ,resultform)
  223.          ,@declarations
  224.          ,@body-rest
  225.        )
  226.       (let ((g (gensym)))
  227.         `(DO ((,var 0 (1+ ,var))
  228.               (,g ,countform))
  229.              ((>= ,var ,g) ,resultform)
  230.            ,@declarations
  231.            ,@body-rest
  232. ) ) ) )  )
  233.  
  234. (sys::%put 'psetq 'sys::macro
  235.   (sys::macro-expander psetq (&whole form &rest args)
  236.     (do* ((setlist nil)
  237.           (bindlist nil)
  238.           (arglist args (cddr arglist)))
  239.          ((null arglist)
  240.           (setq setlist (cons 'NIL setlist))
  241.           (cons 'LET (cons (nreverse bindlist) (nreverse setlist)))
  242.          )
  243.       (if (null (cdr arglist))
  244.         (error #+DEUTSCH "~S mit einer ungeraden Anzahl von Argumenten aufgerufen: ~S"
  245.                #+ENGLISH "~S called with an odd number of arguments: ~S"
  246.                #+FRANCAIS "~S fut appellé avec un nombre impair d'arguments : ~S"
  247.                'psetq form
  248.       ) )
  249.       (let ((g (gensym)))
  250.         (setq setlist (cons `(SETQ ,(first arglist) ,g) setlist))
  251.         (setq bindlist (cons `(,g ,(second arglist)) bindlist))
  252.   ) ) )
  253. )
  254.  
  255. (sys::%put 'multiple-value-list 'sys::macro
  256.   (sys::macro-expander multiple-value-list (form)
  257.     `(MULTIPLE-VALUE-CALL #'LIST ,form)
  258.   )
  259. )
  260.  
  261. (sys::%put 'multiple-value-bind 'sys::macro
  262.   (sys::macro-expander multiple-value-bind (varlist form &body body)
  263.     (let ((g (gensym))
  264.           (poplist nil))
  265.       (dolist (var varlist) (setq poplist (cons `(,var (POP ,g)) poplist)))
  266.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)) ,@(nreverse poplist))
  267.          ,@body
  268.   ) )  )
  269. )
  270.  
  271. (sys::%put 'multiple-value-setq 'sys::macro
  272.   (sys::macro-expander multiple-value-setq (varlist form)
  273.     (let ((g (gensym))
  274.           (poplist nil))
  275.       (dolist (var varlist) (setq poplist (cons `(SETQ ,var (POP ,g)) poplist)))
  276.       `(LET* ((,g (MULTIPLE-VALUE-LIST ,form)))
  277.          ,(if poplist `(PROG1 ,(nreverse poplist)) NIL)
  278.   ) )  )
  279. )
  280.  
  281. (sys::%put 'locally 'sys::macro
  282.   (sys::macro-expander locally (&body body)
  283.     `(LET () ,@body)
  284.   )
  285. )
  286.  
  287. (defmacro case (keyform &body body)
  288.            ;; Common LISP, S. 117
  289.   (let ((var (gensym)))
  290.     `(LET ((,var ,keyform))
  291.        (COND
  292.          ,@(mapcar
  293.              #'(lambda (cl)
  294.                  (unless (consp cl)
  295.                    (error #+DEUTSCH "~S: Keylist fehlt."
  296.                           #+ENGLISH "~S: missing key list"
  297.                           #+FRANCAIS "~S : la liste d'objects-clé manque."
  298.                           'case
  299.                  ) )
  300.                  (let ((kl (first cl)))
  301.                    `(,(cond ((or (eq kl 'T) (eq kl 'OTHERWISE)) 'T)
  302.                             ((listp kl) `(MEMBER ,var ',kl))
  303.                             (t `(EQL ,var ',kl))
  304.                       )
  305.                      ,@(rest cl)
  306.                ) )  )
  307.              body
  308. ) )  ) )   )
  309.  
  310. (defmacro prog (varlist &body body &environment env)
  311.   (multiple-value-bind (body-rest declarations)
  312.                        (sys::parse-body body nil env)
  313.     (if declarations
  314.       (setq declarations (list (cons 'DECLARE declarations)))
  315.     )
  316.     `(BLOCK NIL
  317.        (LET ,varlist
  318.          ,@declarations
  319.          (TAGBODY ,@body-rest)
  320. ) )  ) )
  321.  
  322. (defmacro prog* (varlist &body body &environment env)
  323.   (multiple-value-bind (body-rest declarations)
  324.                        (sys::parse-body body nil env)
  325.     (if declarations
  326.       (setq declarations (list (cons 'DECLARE declarations)))
  327.     )
  328.     `(BLOCK NIL
  329.        (LET* ,varlist
  330.          ,@declarations
  331.          (TAGBODY ,@body-rest)
  332. ) )  ) )
  333.  
  334.  
  335. ;;; Macro-Expander für COND:
  336.  
  337. #|
  338. ;; Dieser hier ist zwar kürzer, aber er reduziert COND auf OR,
  339. ;; das seinerseits wieder auf COND reduziert, ...
  340. (sys::%put 'cond 'sys::macro
  341.   (sys::macro-expander cond (&body clauses)
  342.     (ifify clauses)
  343.   )
  344. )
  345. ; macht eine clauselist von COND zu verschachtelten IFs und ORs.
  346. (defun ifify (clauselist)
  347.   (cond ((null clauselist) NIL)
  348.         ((atom clauselist)
  349.          (error #+DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  350.                 #+ENGLISH "Not a list of COND clauses: ~S"
  351.                 #+FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  352.                 clauselist
  353.         ))
  354.         ((atom (car clauselist))
  355.          (error #+DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  356.                 #+ENGLISH "The atom ~S must not be used as a COND clause."
  357.                 #+FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  358.                 (car clauselist)
  359.         ))
  360.         (t (let ((ifif (ifify (cdr clauselist))))
  361.              (if (cdar clauselist)
  362.                ; mindestens zweielementige Klausel
  363.                (if (constantp (caar clauselist))
  364.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  365.                    (if (cddar clauselist)
  366.                      `(PROGN ,@(cdar clauselist))
  367.                      (cadar clauselist)
  368.                    )
  369.                    ifif
  370.                  )
  371.                  `(IF ,(caar clauselist)
  372.                     ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  373.                     ,ifif
  374.                   )
  375.                )
  376.                ; einelementige Klausel
  377.                (if (constantp (caar clauselist))
  378.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  379.                    (caar clauselist)
  380.                    ifif
  381.                  )
  382.                  `(OR ,(caar clauselist) ,ifif)
  383. ) )     )  ) ) )
  384. |#
  385.  
  386. ;; Noch einfacher ginge es auch so:
  387. #|
  388. (sys::%put 'cond 'sys::macro
  389.   (sys::macro-expander cond (&body clauses)
  390.     (cond ((null clauses) 'NIL)
  391.           ((atom clauses)
  392.            (error #+DEUTSCH "Dotted List im Code von COND, endet mit ~S"
  393.                   #+ENGLISH "COND code contains a dotted list, ending with ~S"
  394.                   #+FRANCAIS "Occurence d'une paire pointée dans le code de COND, terminée en : ~S."
  395.                   clauses
  396.           ))
  397.           (t (let ((clause (car clauses)))
  398.                (if (atom clause)
  399.                  (error #+DEUTSCH "COND-Klausel ohne Test: ~S"
  400.                         #+ENGLISH "COND clause without test: ~S"
  401.                         #+FRANCAIS "Clause COND sans aucun test : ~S"
  402.                         clause
  403.                  )
  404.                  (let ((test (car clause)))
  405.                    (if (cdr clause)
  406.                      `(IF ,test (PROGN ,@(cdr clause)) (COND ,@(cdr clauses)))
  407.                      `(OR ,test (COND ,@(cdr clauses)))
  408. ) ) )     )  ) ) ) )
  409. |#
  410.  
  411. ;; Dieser hier reduziert COND etwas umständlicher auf IF-Folgen:
  412. (sys::%put 'cond 'sys::macro
  413.   (sys::macro-expander cond (&body clauses)
  414.     (let ((g (gensym)))
  415.       (multiple-value-bind (ifif needed-g) (ifify clauses g)
  416.         (if needed-g
  417.           `(LET (,g) ,ifif)
  418.           ifif
  419.   ) ) ) )
  420. )
  421. ; macht eine clauselist von COND zu verschachtelten IFs.
  422. ; Zwei Werte: die neue Form, und ob die Dummyvariable g benutzt wurde.
  423. (defun ifify (clauselist g)
  424.   (cond ((null clauselist) (values NIL nil))
  425.         ((atom clauselist)
  426.          (error #+DEUTSCH "Das ist keine Liste von COND-Klauseln: ~S"
  427.                 #+ENGLISH "Not a list of COND clauses: ~S"
  428.                 #+FRANCAIS "Ceci n'est pas une liste de clauses COND : ~S"
  429.                 clauselist
  430.         ))
  431.         ((atom (car clauselist))
  432.          (error #+DEUTSCH "Das ist ein Atom und daher nicht als COND-Klausel verwendbar: ~S"
  433.                 #+ENGLISH "The atom ~S must not be used as a COND clause."
  434.                 #+FRANCAIS "Ceci est une atome et n'est donc pas utilisable comme clause COND : ~S"
  435.                 (car clauselist)
  436.         ))
  437.         (t (multiple-value-bind (ifif needed-g) (ifify (cdr clauselist) g)
  438.              (if (cdar clauselist)
  439.                ; mindestens zweielementige Klausel
  440.                (if (constantp (caar clauselist))
  441.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  442.                    (if (cddar clauselist)
  443.                      (values `(PROGN ,@(cdar clauselist)) nil)
  444.                      (values (cadar clauselist) nil)
  445.                    )
  446.                    (values ifif needed-g)
  447.                  )
  448.                  (values
  449.                    `(IF ,(caar clauselist)
  450.                         ,(if (cddar clauselist) `(PROGN ,@(cdar clauselist)) (cadar clauselist))
  451.                         ,ifif
  452.                     )
  453.                    needed-g
  454.                ) )
  455.                ; einelementige Klausel
  456.                (if (constantp (caar clauselist))
  457.                  (if (eval (caar clauselist)) ; Test zur Expansionszeit auswerten
  458.                    (values (caar clauselist) nil)
  459.                    (values ifif needed-g)
  460.                  )
  461.                  (if (atom (caar clauselist))
  462.                    (values ; ein Atom produziert nur einen Wert und darf
  463.                      `(IF ,(caar clauselist) ; mehrfach hintereinander
  464.                           ,(caar clauselist) ; ausgewertet werden!
  465.                           ,ifif
  466.                       )
  467.                      needed-g
  468.                    )
  469.                    (values
  470.                      `(IF (SETQ ,g ,(caar clauselist)) ,g ,ifif)
  471.                      t
  472. ) )     )  ) ) ) ) )
  473.  
  474. ;;; Mapping (Kapitel 7.8.4)
  475.  
  476. ; Hilfsfunktion: mapcan, aber mit append statt nconc:
  477. ; (mapcap fun &rest lists) ==  (apply #'append (apply #'mapcar fun lists))
  478. (defun mapcap (fun &rest lists &aux (L nil))
  479.   (loop
  480.     (setq L
  481.       (nconc
  482.         (reverse
  483.           (apply fun
  484.             (maplist #'(lambda (listsr)
  485.                          (if (atom (car listsr))
  486.                            (return)
  487.                            (pop (car listsr))
  488.                        ) )
  489.                      lists
  490.         ) ) )
  491.         L
  492.       )
  493.   ) )
  494.   (sys::list-nreverse L)
  495. )
  496.  
  497. ; Hilfsfunktion: mapcon, aber mit append statt nconc:
  498. ; (maplap fun &rest lists) == (apply #'append (apply #'maplist fun lists))
  499. (defun maplap (fun &rest lists &aux (L nil))
  500.   (loop
  501.     (setq L
  502.       (nconc
  503.         (reverse
  504.           (apply fun
  505.             (maplist #'(lambda (listsr)
  506.                          (if (atom (car listsr))
  507.                            (return)
  508.                            (prog1
  509.                              (car listsr)
  510.                              (setf (car listsr) (cdr (car listsr)))
  511.                        ) ) )
  512.                      lists
  513.         ) ) )
  514.         L
  515.       )
  516.   ) )
  517.   (sys::list-nreverse L)
  518. )
  519.  
  520.